Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/internet/vbipsmtp/smtp.frm

Visual Basic Form | 1996-03-09 | 15.9 KB | 470 lines

VERSION 4.00
Begin VB.Form Form1
   Caption         =   "SMTP Demo"
   ClientHeight    =   6045
   ClientLeft      =   330
   ClientTop       =   375
   ClientWidth     =   9225
   Height          =   6450
   Left            =   270
   LinkTopic       =   "Form1"
   ScaleHeight     =   6045
   ScaleWidth      =   9225
   Top             =   30
   Width           =   9345
   Begin VBX.dsSocket dsSocket1
      BindConnect     =   0   'False
      DataSize        =   2048
      EOLChar         =   0
      Left            =   8055
      LineMode        =   0   'False
      Linger          =   0   'False
      LocalPort       =   0
      RemoteDotAddr   =   ""
      RemoteHost      =   ""
      RemotePort      =   0
      ServiceName     =   ""
      Timeout         =   10
      Top             =   675
   End
   Begin VB.CommandButton btnClear
      Caption         =   "Clear Messsage"
      Height          =   420
      Left            =   6300
      TabIndex        =   13
      Top             =   855
      Width           =   1500
   End
   Begin VB.CommandButton btnAttach
      Caption         =   "Attach File"
      Height          =   420
      Left            =   6300
      TabIndex        =   12
      Top             =   1350
      Width           =   1500
   End
   Begin VB.TextBox txtFrom
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   1
         weight          =   400
         size            =   9.75
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   360
      Left            =   2565
      TabIndex        =   1
      Top             =   675
      Width           =   3525
   End
   Begin VB.TextBox txtSubject
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   1
         weight          =   400
         size            =   9.75
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   360
      Left            =   2565
      TabIndex        =   3
      Top             =   1395
      Width           =   3525
   End
   Begin VB.TextBox txtTo
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   1
         weight          =   400
         size            =   9.75
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   360
      Left            =   2565
      TabIndex        =   2
      Top             =   1035
      Width           =   3525
   End
   Begin VB.TextBox txtMsg
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   1
         weight          =   400
         size            =   9.75
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   3885
      Left            =   180
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   4
      Top             =   1935
      Width           =   8925
   End
   Begin VB.CommandButton btnOK
      Caption         =   "&OK"
      Height          =   375
      Left            =   7965
      TabIndex        =   6
      Top             =   90
      Width           =   1140
   End
   Begin VB.CommandButton btnSend
      Caption         =   "Send"
      Enabled         =   0   'False
      Height          =   420
      Left            =   7965
      TabIndex        =   5
      Top             =   1350
      Width           =   1140
   End
   Begin VB.TextBox txtHost
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   1
         weight          =   400
         size            =   9.75
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   360
      Left            =   2565
      TabIndex        =   0
      Top             =   135
      Width           =   3525
   End
   Begin MSComDlg.CommonDialog dlgFile
      Left            =   8550
      Top             =   630
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
   End
   Begin VB.Label Label1
      Alignment       =   1  'Right Justify
      Caption         =   "Your Address:"
      Height          =   195
      Index           =   5
      Left            =   1035
      TabIndex        =   11
      Top             =   675
      Width           =   1440
   End
   Begin VB.Label Label1
      Alignment       =   1  'Right Justify
      Caption         =   "Subject:"
      Height          =   195
      Index           =   4
      Left            =   1035
      TabIndex        =   10
      Top             =   1395
      Width           =   1440
   End
   Begin VB.Label Label1
      Alignment       =   1  'Right Justify
      Caption         =   "Send To:"
      Height          =   195
      Index           =   2
      Left            =   1035
      TabIndex        =   9
      Top             =   1035
      Width           =   1440
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      Caption         =   "Message:"
      Height          =   195
      Index           =   3
      Left            =   90
      TabIndex        =   8
      Top             =   1710
      Width           =   690
   End
   Begin VB.Label Label1
      Alignment       =   1  'Right Justify
      Caption         =   "SMTP Server Name:"
      Height          =   195
      Index           =   0
      Left            =   180
      TabIndex        =   7
      Top             =   180
      Width           =   2280
   End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
'---------------------------------------------------
'SMTP.FRM
'Copyright 1996 by Carl Franklin
'Unauthorized reproduction in any medium of this
'source code is strictly prohibited without written
'permission from the author and John Wiley & Sons.
'---------------------------------------------------
Sub CheckFields()
    '-- Enables the send button only
    '   if all the fields are filled in.
    If Len(txtHost) Then
        If Len(txtFrom) Then
            If Len(txtTo) Then
                If Len(txtSubject) Then
                    If Len(txtMsg) Then
                        btnSend.Enabled = True
                        Exit Sub
                    End If
                End If
            End If
        End If
    End If
    btnSend.Enabled = False
End Sub
Private Sub btnAttach_Click()
    '-- Set File Dialog options
    dlgFile.Filter = "All Files|*.*"
    dlgFile.DialogTitle = "Select File To Attach"
    dlgFile.filename = "*.*"
    dlgFile.CancelError = True
    '-- Pop up the file dialog box
    On Error Resume Next
    dlgFile.Action = 1
    If Err Then
        '-- Cancel was pressed
        Exit Sub
    End If
    '-- Add this file to the attached file array
    If Len(dlgFile.filename) Then
        gnNumAttachedFiles = gnNumAttachedFiles + 1
        ReDim Preserve gszAttachedFiles(1 To gnNumAttachedFiles) As String
        gszAttachedFiles(gnNumAttachedFiles) = dlgFile.filename
        '-- Print the file name in the Message text box
        txtMsg.SelStart = Len(txtMsg) + 1
        txtMsg.SelText = vbCRLF & "[[ATTACHMENT: " & UCase$(dlgFile.FileTitle) & "]]"
    End If
End Sub
Private Sub btnClear_Click()
    '-- Clear the email message
    txtMsg = ""
    gnNumAttachedFiles = 0
End Sub
Private Sub btnOK_Click()
    '-- Outta here
    Unload Me
End Sub
Sub btnSend_Click()
'-- Send an Email message. All we have to do here is
'   fill in the global strings that make up the message
'   from the text controls, and connect. The protocol does
'   the rest.

    Dim nErrCode    As Integer
    Dim nPos        As Integer
    Dim nPos2       As Integer
    Dim szMsg       As String
    '-- Disable the buttons
    btnSend.Enabled = False
    btnOK.Enabled = False
    Screen.MousePointer = vbHourglass
    '-- Fill in the global strings
    gszFrom = txtFrom
    gszTo = txtTo
    gszSubject = txtSubject
    gszMsg = txtMsg
    '-- Do we have any attached files here?
    If gnNumAttachedFiles Then
        '-- Remove [[ATTACHMENT ...]] lines
        szMsg = txtMsg
        Do
            nPos = InStr(szMsg, "[[ATTACHMENT")
            If nPos Then
                nPos2 = InStr(Mid$(szMsg, nPos), vbCRLF)
                If nPos2 Then
                    szMsg = Left$(szMsg, nPos - 1) & Mid$(szMsg, nPos + nPos2 + 1)
                Else
                    szMsg = Left$(szMsg, nPos - 1)
                End If
            Else
                Exit Do
            End If
        Loop

        '-- UUEncode the attached files (requires UUCODE.BAS)
        nErrCode = nMakeMsgWithFiles(szMsg, gszAttachedFiles(), gszAttachFile)

        If nErrCode Then
            '-- An error occurred.
            btnSend.Enabled = True
            btnOK.Enabled = True
            Screen.MousePointer = vbNormal
            MsgBox "Error when attaching files: " & Error$(nErrCode), vbExclamation
            Exit Sub
        End If
    End If
    '-- Connect to the host
    If SocketConnect(DSSocket1, 25, (txtHost), 30) Then
        '-- An error occurred.
        btnSend.Enabled = True
        btnOK.Enabled = True
        Screen.MousePointer = vbNormal
        MsgBox "Could not connect", vbInformation, "SMTP Client"
    End If
    '-- The protocol takes over from here (DSSocket1_Receive)
End Sub
Sub DSSocket1_Close(ErrorCode As Integer, ErrorDesc As String)
    gnConnected = False
End Sub
Private Sub DSSocket1_Connect()
    gnConnected = True
End Sub
Sub DSSocket1_Receive(ReceiveData As String)
'-- SMTP Client Protocol in action!
    Dim nPos        As Integer      '-- Used with Instr
    Dim nErrCode    As Integer
    Dim nIndex      As Integer
    Dim szFullMsg   As String
    Dim chrTab      As String
    Const chrSpace = " "            '-- Used with Instr
    Const szPeriod = "."            '-- Used to determine the end of x-mission.
    Static nTextMode As Integer     '-- When True, we are receiving data
                                    '   When False, reply codes.
    Static nCode As Integer         '-- The last reply code received.
    Static bReceived220 As Integer  '-- Set true after receiving the first
                                    '   220, indicating a connection.
    chrTab = Chr$(9)
'------------------------------------------------------------------------------
    '-- Grab the reply code.
    nCode = Val(Left$(ReceiveData, 3))
    '-- What is it?
    Select Case nCode

        Case 220    '-- Connect and/or Command OK.
            '-- Is this the first 220?
            If Not bReceived220 Then
                '-- Yep. Flip the flag.
                bReceived220 = True

                '-- This means we're connected. At this
                '   point SocketConnect will exit.
                gnConnected = True

                '-- Send the MAIL command to initiate the send
                '   process.
                SendSMTPCommand DSSocket1, "MAIL FROM: <" & gszFrom & ">"
            End If

        Case 250, 251    '-- Command OK
            '-- What was the last command?
            Select Case gszCommand
                Case "MAIL"
                    '-- After MAIL, send the RCPT command to
                    '   establish the final destination
                    SendSMTPCommand DSSocket1, "RCPT TO: <" & gszTo & ">"
                Case "RCPT"
                    '-- After RCPT, send the DATA command
                    '   to request permission to send the mail message.
                    '   This should yield a 354 reply.
                    SendSMTPCommand DSSocket1, "DATA"
                Case "DATA"
                    '-- We have just sent the message successfully.

                    '-- Confirmation that the message was delivered.
                    MsgBox "Message Delivered", vbInformation, "SMTP Client"

                    btnSend.Enabled = True
                    btnOK.Enabled = True
                    Screen.MousePointer = vbNormal
                    bReceived220 = False
                Case "VRFY"
                    MsgBox Mid$(ReceiveData, 4), vbInformation, "User Verified"
            End Select

        Case 354
            '-- There should only be one command... DATA
            Select Case gszCommand
                Case "DATA"
                    '-- Now we have permission to send the message.
                    '   Compose the complete message. Note the date format.
                    '   This is very important.
                    If gnNumAttachedFiles Then
                        nErrCode = nSendFileAsMsg(gszAttachFile, DSSocket1, 8192, gszFrom, gszTo, gszSubject, "")
                    Else
                        szFullMsg = "DATE: " & Format$(Now, "dd mmm yy ttttt") & vbCRLF _
                           & "FROM: " & gszFrom & vbCRLF _
                           & "TO: " & gszTo & vbCRLF _
                           & "SUBJECT: " & gszSubject & vbCRLF & vbCRLF _
                           & gszMsg & vbCRLF & "." & vbCRLF
                        '-- Don't use SendSMTP command, so the
                        '   last command will still be "DATA"
                        SendData DSSocket1, szFullMsg
                    End If
            End Select

        Case 551
            '-- What was the last command?
            Select Case gszCommand
                Case "RCPT"
                    '-- The specified recipient does not exist here but there is
                    '   a forwarding address. Parse it and resend the RCPT command
                    gszTo = szParseString(ReceiveData, "<", 2)
                    nPos = InStr(gszTo, ">")
                    If nPos Then
                        gszTo = Left$(gszTo, nPos - 1)
                        SendSMTPCommand DSSocket1, "RCPT TO: <" & gszTo & ">"
                    End If
            End Select

        Case Is >= 400

            '-- An error of some sort occurred. Display to the user and
            '   reset everything.

            MsgBox Mid$(ReceiveData, 4), vbInformation, "Error From Server"
            btnSend.Enabled = True
            btnOK.Enabled = True
            Screen.MousePointer = vbNormal
            bReceived220 = False

        Case Else
            '-- Something we were'nt expecting
            Debug.Print ReceiveData
    End Select
End Sub
Sub DSSocket1_SendReady()
    gnSendReady = True
End Sub
Sub Form_Load()
    DSSocket1.LineMode = True
End Sub
Sub Form_Unload(Cancel As Integer)
    SocketDisconnect DSSocket1
    End
End Sub
Private Sub txtFrom_Change()
    CheckFields
End Sub
Private Sub txtHost_Change()
    CheckFields
End Sub
Private Sub txtMsg_Change()

    CheckFields
    If Len(txtMsg) = 0 Then
        gnNumAttachedFiles = 0
    End If
End Sub
Private Sub txtSubject_Change()
    CheckFields
End Sub
Private Sub txtTo_Change()
    CheckFields
End Sub